module Hscm.Parse (parse, parseHscms, doubleParser) where

import Hscm.Value
import Parsec
import Control.Monad
import Control.Monad.Except
import Control.Applicative


parse :: String -> HscmResult HscmValue
parse input = case runParser exprParser input of 
    Left err  -> throwError $ Parse err
    Right (left, val) -> if length left == 0
        then return val
        else throwError $ Parse (ParseError $ "Except end of file, but got '" ++ left ++ "'")


parseHscms :: String -> HscmResult [HscmValue]
parseHscms input = case runParser listNoBacketParser input of
    Left err  -> throwError $ Parse err
    Right (left, List hscms) -> if length left == 0
        then return hscms
        else throwError $ Parse (ParseError $ "Except end of file, but got '" ++ left ++ "'")


exprParser :: Parser HscmValue
exprParser = emptyP *> (
                    stringParser
                <|> doubleParser
                <|> numberParser
                <|> symbolParser
                <|> quotedParser
                <|> listParser
                <|> dottedListParser
            ) <* emptyP


-- "a exmaple of string"
stringParser :: Parser HscmValue
stringParser = String <$> (charP '"' *> (many (noneOfP "\"")) <* charP '"')


-- Begin with a letter or symbol(can't be digit)
-- Follwed by a serial of [letter|digit|symbol]
symbolParser :: Parser HscmValue
symbolParser =  getVal <$> ((:) <$> parseFirst <*> parseRest)
    where
        parseFirst = letterP <|> symbolP
        parseRest  = many (letterP <|> digitP <|> symbolP)

        getVal atom = case atom of 
                "#t" -> Bool True
                "#f" -> Bool False
                _    -> Symbol atom


notNullP :: Parser [a] -> Parser [a]
notNullP (Parser p) = Parser $ \input -> do 
    (input', xs) <- p input
    if null xs
        then Left $ ParseError "Empty list"
        else Right (input', xs)
    

-- Digit number(no support float)
numberParser :: Parser HscmValue
numberParser = (Integer . read) <$> (maybeginWithNeg digitsParser)


-- [-](digit).(digit)
doubleParser :: Parser HscmValue
doubleParser = (Double . read) <$> (maybeginWithNeg parser)
    where
        -- (digit).(digit)
        parser = (\ds1 c ds2 -> ds1 ++ [c] ++ ds2) <$> 
                 digitsParser <*>
                 charP '.' <*>
                 digitsParser


maybeginWithNeg :: Parser String -> Parser String
maybeginWithNeg p = 
    (\bg rest -> case bg of 
        Just c -> c : rest 
        Nothing -> rest) <$>
    (optionCharP '-') <*> p


digitsParser :: Parser String
digitsParser = notNullP (many digitP)

{-
    liftM :: Monad m => (a1 -> r) -> m a1 -> m r
    
    Exmaple:
    1. liftM (*2) [1, 2, 3, 4] => [2, 4, 6, 8]
    2. liftM (*2) (Just 1) => Just 2
    3. liftM (*2) Nothing => Nothing

    List :: [HscmValue] -> HscmValue

    (sepBy exprParser spaces) :: Parser [HscmValue]
-}
listParser :: Parser HscmValue
listParser = List <$> (charP '(' *> emptyP *> elements <* emptyP <* charP ')')
    where
        elements = sepByP emptyP exprParser


listNoBacketParser :: Parser HscmValue
listNoBacketParser = List <$> (emptyP *> elements <* emptyP)
    where
        elements = sepByP emptyP exprParser


-- return :: Monad m => a -> m a
dottedListParser :: Parser HscmValue
dottedListParser = 
    DottedList 
        <$> (charP '(' *> emptyP *> elements)
        <*> (charP '.' *> emptyP *> exprParser <* emptyP <* charP ')')
    where
        elements = sepByP emptyP exprParser


quotedParser :: Parser HscmValue
quotedParser = (\v -> List [Symbol "quote", v]) <$> (charP '\'' *> exprParser)


symbolP :: Parser Char
symbolP = oneOfP "!#$%&|*+-/:<=>?@^_~"


emptyP :: Parser ()
emptyP = spacesP *> commentP *> spacesP


commentP :: Parser ()
commentP = lineBeginWithP ";" <|> noP